{-# LANGUAGE  TypeOperators, FlexibleInstances, TypeFamilies, OverlappingInstances #-}
{- |
Module      :  Helper
Description :  <optional short text displayed on contents page>
Copyright   :  (c) Sergey Sichevskiy 2012
License     :  BSD3

Maintainer  :  s.sichevskij@gmal.com
Stability   :  experimental
Portability :  portable

Вспомогательные функции и типы данных.

-}

module Helper
 ( pair
 , floor'
 , log10
 , ergsToPhotons
 , isZero
 , mkCache
 , memo
 , debug
-- , Numeric(..)
 , ToDouble(..)
 , FromDouble(..)
 , PrettyShow(..)
 ) where

import Text.Printf         ( printf )
import Data.HList          ( HList, Applay, (:::)(..), Null(..) )
import Data.Function       ( on )
import Data.NumInstances   ()

import Control.Applicative ( (<$>) )
import Control.Exception   ( evaluate )
import Data.Maybe          ( fromJust )
import Data.Array.IO       ( IOArray, newArray, getBounds, readArray, writeArray, range )
import System.IO.Unsafe    ( unsafePerformIO )
import System.CPUTime      ( getCPUTime )

foreign import ccall unsafe "math.h floor"
    c_floor :: Double -> Double

floor' :: Double -> Int
{-# INLINE floor' #-}
floor' x = (truncate :: Double -> Int) (c_floor x)

log10 :: Double -> Double
log10 = logBase 10

-- Втягивает функцию на множество пар.
pair :: (a -> b) -> (a, a) -> (b, b)
pair f = uncurry ( (,) `on` f )

-- Пересчет эрги в фотоны
ergsToPhotons :: (Double -> Double) -> Double -> Double
ergsToPhotons f = f * id / hc
  where
    -- Произведение постоянной Планка на скорость  света [erg * А / sec^-1]
    hc = 6.62606896E-27 * 2.99792458E+18

isZero :: (Fractional a, Ord a) => a -> Bool
isZero x = abs x <= 10e-15

type Cache a b = IOArray Int (Maybe (a,b))
                              
mkCache :: Int -> IO (Cache a b)
mkCache n = newArray (0,n-1) Nothing

memo :: Eq a => Cache a b -> (a -> b) -> a -> b
memo c f = unsafePerformIO . lookUp
  where
    -- lookUp :: Eq a => a -> IO b
    lookUp x = getBounds c >>= lookUp' . range
      where
        lookUp' (i:ix) = do

          mxy <- readArray c i
                  
          if (fst <$> mxy) == Just x
             then do
               shift [i,i-1 .. 0]

               writeArray c 0 mxy
                       
               return $ snd $ fromJust mxy

             else do
               lookUp' ix
                  
        lookUp'     [] = do
          (l,r) <- getBounds c

          shift [r,r-1..l]

          y <- evaluate $ f x

          writeArray c 0 $ Just (x,y)
          
          return y

        shift    [ ] = return ()
        shift    [_] = return ()
        shift (i:ix) = readArray c (i-1) >>= writeArray c i >> shift ix

debug :: (Show a, Show b) => ( a -> b ) -> a -> b
debug f a = unsafePerformIO $ do
   let b = f a

   start <- getCPUTime 

   y <- evaluate b

   printf "x = %s ; y = %s\n" (show a) (show y)
--   printf "x = %s " (show a)

   end   <- getCPUTime

   let diff = (fromIntegral (end - start)) / (10**12) :: Double

   putStrLn ("t: " ++ show diff ++ " seconds")

   return y


{--
-- Интегрирование функции методом трапеций.
quad :: (Fractional a, Enum a) => (a,a) -> a -> (a -> a) -> a
quad (a,b) d f = d * (c + e)
   where
      c = 0.5 * (f a + f b)
      e = sum $ [f x | x <- [a+d,a+2*d .. b-d]]
--}

-- class Numeric a where toNum :: Fractional b => a -> b

data   ToDouble =   ToDouble
data FromDouble = FromDouble
--toDouble   ::   ToDouble
--fromDouble :: FromDouble

type instance Applay   ToDouble a = Double
type instance Applay FromDouble (a,Double) = a

class PrettyShow a where
  prettyShow :: a -> String

instance PrettyShow Double where
  prettyShow = printf "%10.4f"

instance PrettyShow Float where
  prettyShow = printf "%10.4f"

instance PrettyShow Null where
  prettyShow _ = ""  

instance (PrettyShow x) => PrettyShow (x:::Null) where
  prettyShow (x:::_) = prettyShow x

instance (PrettyShow x, PrettyShow xs, HList xs) => PrettyShow (x:::xs) where
  prettyShow (x:::xs) = prettyShow x ++ ", " ++ prettyShow xs